home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
Xteq X-Setup
/
xqdcXSP-Setup-EN.exe
/
{app}
/
plugins
/
svho IE Edit Context Menu.xpl
< prev
next >
Wrap
Text File
|
2003-11-19
|
13KB
|
435 lines
"FILE"="Xteq Systems X-Setup Plugin 6.0"
"TYPE"="8"
"COUNT"="3"
"TEXT 1"="&Edit"
"TEXT 2"="&Add new"
"TEXT 3"="&Delete"
"UIPATH"="Internet\Internet Explorer\Context Menu Entries"
"NAME"="Editor"
"LANGUAGE"="VBScript"
"DESCRIPTION 1"="This plug-in edits entries in Internet Explorer context menu. You may need to restart Internet Explorer to make it work."
"DESCRIPTION 2"="NOTE #1: Entries, that begin with '[]' are unvisible."
"DESCRIPTION 3"="NOTE #2: Entries, that begin with '!!' are visible, but IE shows them not, because they are useless (without default URL)."
"DESCRIPTION 4"="NOTE #3: To only rename the entry, click 'Edit', change the name, click 'OK' and then 'Cancel'.
"VERSION"="1.02"
"AUTHOR"="Svyatoslav Holub"
"CONTACTURL"="mailto:jobvonzuhause@everyday.com"
"COPYRIGHT"="This plug-in is Freeware. Use at your own risk!"
"COMMENT 1"="Tested on Windows 98SE with Internet Explorer 6.0"
"ADMINRIGHTS"="0"
"OSVERSION"="0111111"
visibleMenuExt="HKCU\Software\Microsoft\Internet Explorer\MenuExt"
unvisibleMenuExt="HKCU\Software\Microsoft\Internet Explorer\MenuExt-"
const vMark ="[] " 'indicates unvisibility
const uMark ="!! " 'indicates useless
dim visibleCount, unvisibleCount
dim visibleMenuExists, unvisibleMenuExists
dim vMarkLength, uMarkLength
dim trueNames()
Sub Plugin_Initialize
vMarkLength = Len(vMark)
uMarkLength = Len(uMark)
'Clear listbox
elemNumber = visibleCount + unvisibleCount
For l = 1 to elemNumber
SetUIElement l, ""
Next
'Clear names array
Redim trueNames(0)
visibleCount = 0
unvisibleCount = 0
visibleMenuExists = RegPathExists(visibleMenuExt)
unvisibleMenuExists = RegPathExists(unvisibleMenuExt)
dim falseNames
If visibleMenuExists = true Then
visibleCount=RegEnumPaths(visibleMenuExt)
If CBool (visibleCount) Then listAddNew visibleCount, 0, true, falseNames
End If
If unvisibleMenuExists = true Then
unvisibleCount=RegEnumPaths(unvisibleMenuExt)
If CBool (unvisibleCount) Then listAddNew unvisibleCount, visibleCount, false, falseNames
End If
If falseNames <> "" Then MsgWarning "Following context menu names begin with " & _
vMark & "or " & uMark & ":" & vbCrLf & vbCrLf & _
falseNames & vbCrLf & "The plug-in uses this characters " & _
"to indicate entry properties." & vbCrLf & _
"Please rename this entries with 'Edit'-button."
'If visibleCount + unvisibleCount = 0 Then Disable
End Sub
Sub listAddNew (elemCounter, listCounter, visibilityFlag, ByRef falseNames)
For i=1 to elemCounter
extText=RegEnumElement(i)
j = i + listCounter
Redim Preserve trueNames(j)
trueNames(j) = extText
If Len(extText) > 1 Then _
If Left(extText,2)=Left(uMark,2) OR Left(extText,2)=Left(vMark,2) Then _
falseNames = falseNames & vbTab & extText & vbCrLf
If visibilityFlag = false Then
SetUIElement j, vMark & extText
Else
If RegReadValue(visibleMenuExt & "\" & extText & "\" & "@")="" Then
SetUIElement j, uMark & extText
Else
SetUIElement j, extText
End If
End If
Next
End Sub
Sub Plugin_Apply(ElementIndex,ElementSubIndex)
'Nothing to do, if IE settings in Registry were meantime for example manual changed.
If RegistryChanged = true Then Exit Sub
Select Case ElementIndex
Case 1 'edit
If ElementSubIndex <> 0 Then editEntry ElementSubIndex
Case 2 'add new
addEntry
Case 3 'delete
If ElementSubIndex <> 0 Then deleteEntry ElementSubIndex
Case Else
'not possible
End Select
End Sub
Sub editEntry (entryIndex)
changed = false
If entryIndex <> 0 Then
If entryIndex > visibleCount Then
fullName = unvisibleMenuExt & "\" & trueNames(entryIndex)
visibility = false
Else
fullName = visibleMenuExt & "\" & trueNames(entryIndex)
visibility = true
End If
Else
visibility = true
End If
dim editValues(3)
editValues(3) = visibility
'show input windows
For i=1 to 4
answer = DataInput (i, fullName, entryIndex, editValues)
If IsEmpty(answer) = true Then Exit For
Next
If IsEmpty(editValues(0)) = true Then Exit Sub
If editValues(0) <> trueNames(entryIndex) OR editValues(3) <> visibility Then
If editValues(3) = true Then _
fullDestination = visibleMenuExt & "\" & editValues(0) Else _
fullDestination = unvisibleMenuExt & "\" & editValues(0)
If RegistryChanged = true Then Exit Sub
If entryIndex <> 0 Then moveSubKey fullName, fullDestination _
Else RegWriteValue fullDestination & "\@", "", 1
changed = true
fullName = fullDestination
End If
If IsEmpty(editValues(1)) = true Then
If changed = true Then
IndicateSettingChange
Plugin_Initialize
End If
Exit Sub
End If
RegWriteValue fullName & "\@", editValues(1), 1
If IsEmpty(editValues(2)) = true Then
If changed = true Then
IndicateSettingChange
Plugin_Initialize
End If
Exit Sub
End If
If editValues(2) = "" Then
If RegValueExists(fullName & "\contexts") = true Then _
RegDeleteValue fullName & "\contexts"
Else
RegWriteValue fullName & "\contexts", editValues(2), 3
End If
If changed = true Then
IndicateSettingChange
Plugin_Initialize
End If
End Sub
Sub addEntry
editEntry 0
End Sub
Sub deleteEntry (entryIndex)
If entryIndex > visibleCount Then
deleteSubKey unvisibleMenuExt & "\" & trueNames(entryIndex)
Else
deleteSubKey visibleMenuExt & "\" & trueNames(entryIndex)
IndicateSettingChange
End If
Plugin_Initialize
End Sub
'show input windows
'check, convert and save input values
Function DataInput(inputIndex, fullKeyName, namesIndex, ByRef values)
'show input windows with values
Select Case inputIndex
Case 1 'entry name
text = "Enter context menu name, which can include an ampersand character to cause " & _
"the character that follows to be underlined and used as a shortcut key:"
value = trueNames(namesIndex)
Case 2 'default URL
text = "Enter URL of the page that contains the script, which you want to execute:" & vbCrLf & _
"(if URL is empty, IE shows this entry not!)"
If namesIndex <> 0 Then value = RegReadValue(fullKeyName & "\@") _
Else value = ""
Case 3 'contexts
text = "Which contexts this entry should appear? " & _
"Use the logical OR of the following values:" & vbCrLf & _
"00000001-default" & vbTab & "00001000-tables" & vbCrLf & _
"00000010-images" & vbTab & "00010000-selection " & vbCrLf & _
"00000100-controls" & vbTab & "00100000-anchor"
If namesIndex <> 0 Then
If RegValueExists(fullKeyName & "\contexts")=true Then _
valueType=RegValueType(fullKeyName & "\contexts")
value = RegReadValue(fullKeyName & "\contexts")
If value <> Empty Then
'convert only last byte
If valueType=3 Then value=CLng("&H" & Right(value,2))
If valueType=2 OR valueType=3 Then value=dez2bin(value)
Else
value = ""
End If
Else
value = "00000001"
End If
Case 4 'visibility
text = "Are you want to make this entry visible (Yes/No)?"
If namesIndex > visibleCount Then value = "No" Else value = "Yes"
Case Else
Err.Raise vbObjectError + 1, "Function DataInput", "inputIndex (" & inputIndex & ") is out of bound (4)!"
End Select
Do 'check input data
reinput = false
answer = InputWindow(text,value,1)
If IsEmpty(answer) = true Then Exit Function
'syntax check and data convert
Select Case inputIndex
Case 1 'entry name
If Trim(answer) = "" Then
reinput = true
ElseIf Len(Trim(answer)) > 1 Then
If Left(Trim(answer),2)=Left(uMark,2) OR Left(Trim(answer),2)=Left(vMark,2) Then
MsgWarning "Names, which begin with " & _
uMark & "or " & vMark & _
"are not allowed!"
reinput = true
End If
End If
If reinput = false Then
If LCase(answer) <> LCase(trueNames(namesIndex)) Then
For c=1 To UBound(trueNames)
If LCase(answer) = LCase(trueNames(c)) Then
MsgWarning "This name already exists!"
reinput = true
Exit For
End If
Next
End If
End If
Case 2 'default URL
If Trim(answer) = "" AND answer <> "" Then reinput = true
Case 3 'contexts
If answer = "" Then
'nothing to do
ElseIf Len(answer)=8 Then
For i=1 To Len(answer)
char = Mid(answer,i,1)
Select Case char
Case "0", "1"
filtredAnswer = filtredAnswer & char
Case Else
'nothing to do
End Select
Next
If answer = filtredAnswer Then
answer = bin2hex(answer)
Else
reinput = true
End If
Else
reinput = true
End If
Case 4 'visibility
If LCase(answer)="yes" Then
answer = true
ElseIf LCase(answer)="no" Then
answer = false
Else
reinput = true
End If
Case Else
'unpossible
End Select
value = answer
Loop While reinput = true
values(inputIndex-1) = answer
DataInput = answer
End Function
Function bin2hex(binValue)
For i=0 To 7
dezValue = dezValue + Mid(binValue,8-i,1)*2^(i)
Next
bin2hex = Hex(dezValue)
If Len(bin2hex) = 1 Then bin2hex = "0" & bin2hex
End Function
'convert only last byte
Function dez2bin(ByVal dezValue)
For i=1 to 8
bit = (dezValue Mod 2) & bit
dezValue = dezValue \ 2
Next
dez2bin = bit
End Function
Sub moveSubKey (fullSourceKey, fullDestinationKey)
dim i, j
dim pathsCount, valuesCount
dim defaultString, value, data, dataType
pathsCount = RegEnumPaths(fullSourceKey)
If pathsCount <> 0 Then
For j=1 to pathsCount
moveSubKey fullSourceKey & "\" & RegEnumElement(j), fullDestinationKey & "\" & RegEnumElement(j)
Next
End If
defaultString = RegReadValue(fullSourceKey & "\@")
RegWriteValue fullDestinationKey & "\@", defaultString, 1
valuesCount = RegEnumValues(fullSourceKey)
For i=1 to valuesCount
value = RegEnumElement(i)
data = RegReadValue(fullSourceKey & "\" & value)
dataType = RegValueType(fullSourceKey & "\" & value)
RegWriteValue fullDestinationKey & "\" & value, data, dataType
RegDeleteValue fullSourceKey & "\" & value
Next
RegDeletePath fullSourceKey
End Sub
Sub deleteSubKey (fullName)
dim x, y
dim values, pathsCount
pathsCount = RegEnumPaths(fullName)
If pathsCount <> 0 Then
For x=1 to pathsCount
deleteSubKey fullName & "\" & RegEnumElement(x)
Next
End If
values = RegEnumValues(fullName)
For y=1 to values
valueName = RegEnumElement(y)
RegDeleteValue fullName & "\" & valueName
Next
RegDeletePath fullName
End Sub
'Check, if IE settings in Registry were meantime for example manual changed.
'If yes, plug-in restarts.
Function RegistryChanged
If visibleMenuExists <> RegPathExists(visibleMenuExt) Then
IndicateSettingChange
RestartMessage
RegistryChanged = true
Exit Function
ElseIf visibleMenuExists = true Then
If visibleCount <> RegEnumPaths(visibleMenuExt) Then
IndicateSettingChange
RestartMessage
RegistryChanged = true
Exit Function
End If
End If
If unvisibleMenuExists <> RegPathExists(unvisibleMenuExt) Then
RestartMessage
RegistryChanged = true
Exit Function
ElseIf unvisibleMenuExists = true Then
If unvisibleCount <> RegEnumPaths(unvisibleMenuExt) Then
RestartMessage
RegistryChanged = true
Exit Function
End If
End If
For i=1 to visibleCount
If RegPathExists(visibleMenuExt & "\" & trueNames(i)) = false Then
IndicateSettingChange
RestartMessage
RegistryChanged = true
Exit Function
End If
Next
elCount = visibleCount + unvisibleCount
For i=visibleCount + 1 to elCount
If RegPathExists(unvisibleMenuExt & "\" & trueNames(i)) = false Then
RestartMessage
RegistryChanged = true
Exit Function
End If
Next
RegistryChanged = false
End Function
Sub RestartMessage
Plugin_Initialize
MsgWarning "Plug-in is restarted, because" & vbCrLf & _
"Registry was changed!" & vbCrLf & "Your changes were not applied."
End Sub
Sub Plugin_Terminate
End Sub